home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / dejagnu.lha / dejagnu-1.0.1 / dejagnu / tcl-mode.el < prev    next >
Lisp/Scheme  |  1993-02-21  |  13KB  |  397 lines
  1. ;; Tcl code editing commands for Emacs
  2. ;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 1, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ; Written by Chris Lindblad <cjl@lcs.mit.edu>.
  21.  
  22. (provide 'tcl-mode)
  23.  
  24. (defvar tcl-mode-abbrev-table nil
  25.   "Abbrev table in use in Tcl-mode buffers.")
  26.  
  27. (define-abbrev-table 'tcl-mode-abbrev-table ())
  28.  
  29. (defvar last-depth
  30.   "Added to remove error message.")
  31.  
  32. (defvar tcl-mode-map ()
  33.   "Keymap used in Tcl mode.")
  34.  
  35. (if tcl-mode-map
  36.     ()
  37.   (setq tcl-mode-map (make-sparse-keymap))
  38.   (define-key tcl-mode-map "{" 'electric-tcl-brace)
  39.   (define-key tcl-mode-map "}" 'electric-tcl-brace)
  40.   (define-key tcl-mode-map "[" 'electric-tcl-brace)
  41.   (define-key tcl-mode-map "]" 'electric-tcl-brace)
  42.   (define-key tcl-mode-map "\e\C-a" 'tcl-beginning-of-defun)
  43.   (define-key tcl-mode-map "\e\C-e" 'tcl-end-of-defun)
  44.   (define-key tcl-mode-map "\e\C-q" 'indent-tcl-exp)
  45.   (define-key tcl-mode-map "\177" 'backward-delete-char-untabify)
  46.   (define-key tcl-mode-map "\t" 'tcl-indent-command))
  47.  
  48. (defvar tcl-mode-syntax-table nil
  49.   "Syntax table in use in Tcl-mode buffers.")
  50.  
  51. (if tcl-mode-syntax-table
  52.     ()
  53.   (setq tcl-mode-syntax-table (make-syntax-table))
  54.   (modify-syntax-entry ?%  "." tcl-mode-syntax-table)
  55.   (modify-syntax-entry ?&  "." tcl-mode-syntax-table)
  56.   (modify-syntax-entry ?*  "." tcl-mode-syntax-table)
  57.   (modify-syntax-entry ?+  "." tcl-mode-syntax-table)
  58.   (modify-syntax-entry ?-  "." tcl-mode-syntax-table)
  59.   (modify-syntax-entry ?/  "." tcl-mode-syntax-table)
  60.   (modify-syntax-entry ?<  "." tcl-mode-syntax-table)
  61.   (modify-syntax-entry ?=  "." tcl-mode-syntax-table)
  62.   (modify-syntax-entry ?>  "." tcl-mode-syntax-table)
  63.   (modify-syntax-entry ?|  "." tcl-mode-syntax-table))
  64.  
  65. (defvar tcl-indent-level 4
  66.   "*Indentation of Tcl statements with respect to containing block.")
  67.  
  68. (defvar tcl-auto-newline nil
  69.   "*Non-nil means automatically newline before and after braces,
  70. and after colons and semicolons, inserted in Tcl code.")
  71.  
  72. (defvar tcl-tab-always-indent t
  73.   "*Non-nil means TAB in Tcl mode should always reindent the current line,
  74. regardless of where in the line point is when the TAB command is used.")
  75.  
  76. (defun tcl-mode ()
  77.   "Major mode for editing Tcl code.
  78. Expression and list commands understand all Tcl brackets.
  79. Tab indents for Tcl code.
  80. Paragraphs are separated by blank lines only.
  81. Delete converts tabs to spaces as it moves back.
  82. \\{tcl-mode-map}
  83. Variables controlling indentation style:
  84.  tcl-tab-always-indent
  85.     Non-nil means TAB in Tcl mode should always reindent the current line,
  86.     regardless of where in the line point is when the TAB command is used.
  87.  tcl-auto-newline
  88.     Non-nil means automatically newline before and after braces,
  89.     inserted in Tcl code.
  90.  tcl-indent-level
  91.     Indentation of Tcl statements within surrounding block.
  92.     The surrounding block's indentation is the indentation
  93.     of the line on which the open-brace appears.
  94.  
  95. Turning on Tcl mode calls the value of the variable tcl-mode-hook with no args,
  96. if that value is non-nil."
  97.   (interactive)
  98.   (kill-all-local-variables)
  99.   (use-local-map tcl-mode-map)
  100.   (setq major-mode 'tcl-mode)
  101.   (setq mode-name "Tcl")
  102.   (setq local-abbrev-table tcl-mode-abbrev-table)
  103.   (set-syntax-table tcl-mode-syntax-table)
  104.   (make-local-variable 'paragraph-start)
  105.   (setq paragraph-start (concat "^$\\|" page-delimiter))
  106.   (make-local-variable 'paragraph-separate)
  107.   (setq paragraph-separate paragraph-start)
  108.   (make-local-variable 'paragraph-ignore-fill-prefix)
  109.   (setq paragraph-ignore-fill-prefix t)
  110.   (make-local-variable 'indent-line-function)
  111.   (setq indent-line-function 'tcl-indent-line)
  112.   (make-local-variable 'require-final-newline)
  113.   (setq require-final-newline t)
  114.   (make-local-variable 'comment-start)
  115.   (setq comment-start "# ")
  116.   (make-local-variable 'comment-end)
  117.   (setq comment-end "\n")
  118.   (make-local-variable 'parse-sexp-ignore-comments)
  119.   (setq parse-sexp-ignore-comments t)
  120.   (run-hooks 'tcl-mode-hook))
  121.  
  122.  
  123. (defun electric-tcl-brace (arg)
  124.   "Insert character and correct line's indentation."
  125.   (interactive "P")
  126.   (let (insertpos)
  127.     (if (and (not arg)
  128.          (eolp)
  129.          (or (save-excursion
  130.            (skip-chars-backward " \t")
  131.            (bolp))
  132.          (if (and tcl-auto-newline 
  133.               (or (= last-command-char ?{)
  134.                   (= last-command-char ?{)))
  135.              (progn
  136.                (tcl-indent-line)
  137.                (newline) 
  138.                t)
  139.            nil)))
  140.     (progn
  141.       (insert last-command-char)
  142.       (tcl-indent-line)
  143.       (if tcl-auto-newline
  144.           (progn
  145.         (newline)
  146.         (setq insertpos (- (point) 2))
  147.         (tcl-indent-line)))
  148.       (save-excursion
  149.         (if insertpos (goto-char (1+ insertpos)))
  150.         (delete-char -1))))
  151.     (if insertpos
  152.     (save-excursion
  153.       (goto-char insertpos)
  154.       (self-insert-command (prefix-numeric-value arg)))
  155.       (self-insert-command (prefix-numeric-value arg)))))
  156.  
  157.  
  158. (defun tcl-indent-command (&optional ignore)
  159.   "Indent current line as Tcl code, or in some cases insert a tab character.
  160. If tcl-tab-always-indent is non-nil (the default), always indent current line.
  161. Otherwise, indent the current line only if point is at the left margin
  162. or in the line's indentation; otherwise insert a tab."
  163.   (interactive "P")
  164.   (if (and (not tcl-tab-always-indent)
  165.        (save-excursion
  166.          (skip-chars-backward " \t")
  167.          (not (bolp))))
  168.       (insert-tab)
  169.     (tcl-indent-line)))
  170.  
  171. (defun tcl-indent-line ()
  172.   "Indent current line as Tcl code.
  173. Return the amount the indentation changed by."
  174.   (let ((indent (calculate-tcl-indent nil))
  175.     beg shift-amt
  176.     (case-fold-search nil)
  177.     (pos (- (point-max) (point))))
  178.     (beginning-of-line)
  179.     (setq beg (point))
  180.     (cond ((eq indent nil)
  181.        (setq indent (current-indentation)))
  182.       (t
  183.        (skip-chars-forward " \t")
  184.        (if (listp indent) (setq indent (car indent)))
  185.        (cond ((= (following-char) ?})
  186.           (setq indent (- indent tcl-indent-level)))
  187.          ((= (following-char) ?\])
  188.           (setq indent (- indent 1))))))
  189.     (skip-chars-forward " \t")
  190.     (setq shift-amt (- indent (current-column)))
  191.     (if (zerop shift-amt)
  192.     (if (> (- (point-max) pos) (point))
  193.         (goto-char (- (point-max) pos)))
  194.       (delete-region beg (point))
  195.       (indent-to indent)
  196.       ;; If initial point was within line's indentation,
  197.       ;; position after the indentation.  Else stay at same point in text.
  198.       (if (> (- (point-max) pos) (point))
  199.       (goto-char (- (point-max) pos))))
  200.     shift-amt))
  201.  
  202. (defun calculate-tcl-indent (&optional parse-start)
  203.   "Return appropriate indentation for current line as Tcl code.
  204. In usual case returns an integer: the column to indent to.
  205. Returns nil if line starts inside a string, t if in a comment."
  206.   (save-excursion
  207.     (beginning-of-line)
  208.     (let ((indent-point (point))
  209.       (case-fold-search nil)
  210.       (continued-line 
  211.        (save-excursion
  212.          (if (bobp)
  213.          nil
  214.            (backward-char)
  215.            (= (preceding-char) ?\\))))
  216.       state
  217.       containing-sexp)
  218.       (if parse-start
  219.       (goto-char parse-start)
  220.     (beginning-of-defun))
  221.       (while (< (point) indent-point)
  222.     (setq parse-start (point))
  223.     (setq state (parse-partial-sexp (point) indent-point 0))
  224.     (setq containing-sexp (car (cdr state))))
  225.       (cond ((or (nth 3 state) (nth 4 state))
  226.          ;; return nil or t if should not change this line
  227.          (nth 4 state))
  228.         ((null containing-sexp)
  229.          ;; Line is at top level.
  230.          (if continued-line tcl-indent-level 0))
  231.         (t
  232.          ;; Find the first statement in the block and indent like it.
  233.          (goto-char containing-sexp)
  234.          (forward-line)
  235.          ;; Skip to first non-empty line in block.
  236.          (while (and (< (point) indent-point)
  237.              (eolp))
  238.            (forward-line))
  239.          ;; Count it if it exists
  240.          (if (< (point) indent-point)
  241.          (if continued-line 
  242.              (+ (current-indentation) tcl-indent-level)
  243.            (current-indentation))
  244.            ;; If no previous statement, indent it relative to line
  245.            ;; brace is on.
  246.            (goto-char containing-sexp)
  247.            (if (/= (following-char) ?{)
  248.            (+ (current-column) 1)
  249.          (beginning-of-line)
  250.          (+ (current-indentation) tcl-indent-level))))))))
  251.  
  252.  
  253. (defun mark-tcl-function ()
  254.   "Put mark at end of Tcl function, point at beginning."
  255.   (interactive)
  256.   (push-mark (point))
  257.   (end-of-defun)
  258.   (push-mark (point))
  259.   (beginning-of-defun)
  260.   (backward-paragraph))
  261.  
  262.  
  263. (defun indent-tcl-exp ()
  264.   "Indent each line of the Tcl grouping following point."
  265.   (interactive)
  266.   (let ((indent-stack (list nil))
  267.     (contain-stack (list (point)))
  268.     (case-fold-search nil)
  269.     restart outer-loop-done inner-loop-done state ostate
  270.     this-indent last-sexp
  271.     at-else at-brace continued-line
  272.     (opoint (point))
  273.     (next-depth 0))
  274.     (save-excursion
  275.       (forward-sexp 1))
  276.     (save-excursion
  277.       (setq outer-loop-done nil)
  278.       (while (and (not (eobp)) (not outer-loop-done))
  279.     (setq last-depth next-depth)
  280.     ;; Compute how depth changes over this line
  281.     ;; plus enough other lines to get to one that
  282.     ;; does not end inside a comment or string.
  283.     ;; Meanwhile, do appropriate indentation on comment lines.
  284.     (setq inner-loop-done nil)
  285.     (while (and (not inner-loop-done)
  286.             (not (and (eobp) (setq outer-loop-done t))))
  287.       (setq ostate state)
  288.       (setq state (parse-partial-sexp (point) (progn (end-of-line) (point))
  289.                       nil nil state))
  290.       (setq next-depth (car state))
  291.       (if (and (car (cdr (cdr state)))
  292.            (>= (car (cdr (cdr state))) 0))
  293.           (setq last-sexp (car (cdr (cdr state)))))
  294.       (if (or (nth 4 ostate))
  295.           (tcl-indent-line))
  296.       (if (or (nth 3 state))
  297.           (forward-line 1)
  298.         (setq inner-loop-done t)))
  299.     (if (<= next-depth 0)
  300.         (setq outer-loop-done t))
  301.     (if outer-loop-done
  302.         nil
  303.       ;; If this line had ..))) (((.. in it, pop out of the levels
  304.       ;; that ended anywhere in this line, even if the final depth
  305.       ;; doesn't indicate that they ended.
  306.       (while (> last-depth (nth 6 state))
  307.         (setq indent-stack (cdr indent-stack)
  308.           contain-stack (cdr contain-stack)
  309.           last-depth (1- last-depth)))
  310.       (if (/= last-depth next-depth)
  311.           (setq last-sexp nil))
  312.       ;; Add levels for any parens that were started in this line.
  313.       (while (< last-depth next-depth)
  314.         (setq indent-stack (cons nil indent-stack)
  315.           contain-stack (cons nil contain-stack)
  316.           last-depth (1+ last-depth)))
  317.       (if (null (car contain-stack))
  318.           (setcar contain-stack 
  319.               (or (car (cdr state))
  320.               (save-excursion
  321.                 (forward-sexp -1)
  322.                 (point)))))
  323.       (forward-line 1)
  324.       (setq continued-line 
  325.         (save-excursion
  326.           (backward-char)
  327.           (= (preceding-char) ?\\)))
  328.       (skip-chars-forward " \t")
  329.       (if (eolp)
  330.           nil
  331.         (if (and (car indent-stack)
  332.              (>= (car indent-stack) 0))
  333.         ;; Line is on an existing nesting level.
  334.         (setq this-indent (car indent-stack))
  335.           ;; Just started a new nesting level.
  336.           ;; Compute the standard indent for this level.
  337.           (let ((val (calculate-tcl-indent
  338.               (if (car indent-stack)
  339.                   (- (car indent-stack))))))
  340.         (setcar indent-stack
  341.             (setq this-indent val))
  342.         (setq continued-line nil)))
  343.         (cond ((not (numberp this-indent)))
  344.           ((= (following-char) ?})
  345.            (setq this-indent (- this-indent tcl-indent-level)))
  346.           ((= (following-char) ?\])
  347.            (setq this-indent (- this-indent 1))))
  348.         ;; Put chosen indentation into effect.
  349.         (or (null this-indent)
  350.         (= (current-column) 
  351.            (if continued-line 
  352.                (+ this-indent tcl-indent-level)
  353.              this-indent))
  354.         (progn
  355.           (delete-region (point) (progn (beginning-of-line) (point)))
  356.           (indent-to 
  357.            (if continued-line 
  358.                (+ this-indent tcl-indent-level)
  359.              this-indent)))))))))
  360.   )
  361.  
  362. (defun tcl-beginning-of-defun (&optional arg)
  363.   "Move backward to next beginning-of-defun.
  364. With argument, do this that many times.
  365. Returns t unless search stops due to end of buffer."
  366.   (interactive "p")
  367.   (if (or (null arg) (= arg 0)) (setq arg 1))
  368.   (let (success)
  369.     (while (and (>= (setq arg (- arg 1)) 0)
  370.         (setq success (re-search-backward "^\\S " nil 'move 1)))
  371.       (while (and (looking-at "[]#}]")
  372.           (setq success (re-search-backward "^\\S " nil 'move 1)))))
  373.     (beginning-of-line)
  374.     (not (null success))))
  375.  
  376. (defun tcl-end-of-defun (&optional arg)
  377.   "Move forward to next end of defun.
  378. An end of a defun is found by moving forward from the beginning of one."
  379.   (interactive "p")
  380.   (if (or (null arg) (= arg 0)) (setq arg 1))
  381.   (let ((start (point)))
  382.     (forward-char)
  383.     (tcl-beginning-of-defun)
  384.     (while (> arg 0)
  385.       (while (and (re-search-forward "^\\S " nil 'move 1)
  386.           (progn (beginning-of-line) t)
  387.           (looking-at "[]#}]")
  388.           (progn (forward-line) t)))
  389.       (let ((next-line (save-excursion 
  390.              (forward-line)
  391.              (point))))
  392.     (while (< (point) next-line)
  393.       (forward-sexp)))
  394.       (forward-line)
  395.       (if (> (point) start) (setq arg (1- arg))))))
  396.  
  397.